perm filename LCPCRS.PAS[PAS,SYS] blob
sn#483426 filedate 1979-10-16 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00003 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 PROGRAM CROSS
C00055 00003 EXIT IF SYTY # SEMICOLON
C00080 ENDMK
C⊗;
PROGRAM CROSS;
%$L-,C-\
(*PROGRAM WHICH CREATES A CROSS REFERENCE LISTING WITH SIMULTANEOUS
FORMATTING OF A PASCAL PROGRAM. WRITTEN BY MANUEL MALL.
THE FOLLOWING CHANGES WERE MADE HERE BY LARRY PAULSON:
! I. SPEED-UPS
! A. NO LINE NUMBERS ARE PUT ON THE 'NEW' FILE.
! B. THE /F SWITCH SUPPRESSES THE LISTING OF THE SOURCE FILE.
! THE CROSS-REFERENCE APPEARS AS FILE '<NAME>.CRL'.
!
! II. SYNTAX CHANGES
! A. SOURCE FILES WITH NO MAIN PROGRAM (THE $M- SWITCH) DO NOT CAUSE
! ERROR MESSAGES. '(NO MAIN PROGRAM)' IS PRINTED ON THE TERMINAL.
! CROSS DOES NOT NOTICE IF THE SWITCH IS ACTUALLY PRESENT.
!
! III. CHANGES TO THE CROSS-REFERENCE LISTING
! A. NO PAGE NUMBERS ARE PRINTED IN THE LISTING IF NO SOS PAGE MARKS
! WERE USED.
! B. IF AN IDENTIFIER IS REFERENCED MORE THAN ONCE ON THE SAME LINE,
! THE LINE IS STILL MENTIONED ONLY ONCE.
!
! IV. GENERAL
! A. IF NO OUTPUTFILE IS GIVEN, '<NAME>.NEW' IS ASSUMED.
! IF NO INPUTFILE IS GIVEN, IT IS TAKEN TO BE THE SAME AS THE OUTPUTFILE.
! B. THE INDENTATION CONSTANT MAY BE SET BY '/INDENT:<INTEGER>', WHICH
! MAY BE ABBREVIATED '/I<INTEGER>', E.G. '/I3'. DEFAULT IS 4.
! C. '←' MAY BE USED FOR '=' IN THE INPUT LINE. *)
CONST
VERSION = 'CROSS VERSION OF APRIL 15, 1977';
MAXCH = 114; %MAXIMUM NUMBER OF CHARS PER PRINT LINE\
MAXLINE = 57; %MAXIMAL NUMBER OF LINES PER PRINT PAGE\
HT = 11B; %ASCII HORIZONTAL TAB\
LF = 12B; %ASCII LINE FEED\
FF = 14B; %ASCII FORM FEED\
CR = 15B; %ASCII CARIAGE RETURN\
TYPE
ERRKINDS = (ERRINBLKSTR,MISSGENDUNTIL,MISSGTHEN,MISSGOF,MISSGEXIT,MISSGRPAR,MISSGQUOTE);
ROUTINFO = (NOTROUT, PROC, FUNC);
LINEPTRTY = ↑LINE;
LISTPTRTY = ↑LIST;
PROCCALLTY = ↑PROCCALL;
PROCSTRUCTY = ↑PROCSTRUC;
LINENRTY = 0..17777B; %MEANS MAX LINE COUNT IS 8000\
PAGENRTY = 0..37B; %AND.. MAX PAGE COUNT IS 32\
WORD = PACKED ARRAY [1..10] OF CHAR;
SYMBOL = (LABELSY,CONSTSY,TYPESY,VARSY, %DECSYM\
FUNCTIONSY,PROCEDURESY,INITPROCSY, %PROSYM\
ENDSY,UNTILSY,ELSESY,THENSY,EXITSY,OFSY,DOSY,EOBSY, %ENDSYMBOLS\
BEGINSY,CASESY,LOOPSY,REPEATSY,IFSY, %BEGSYM\
RECORDSY,FORWARDSY,GOTOSY,OTHERSY,INTCONST,IDENT,STRGCONST,EXTERNSY,LANGSY,
RPARENT,SEMICOLON,POINT,LPARENT,COLON,LBRACK,OTHERSSY%DELIMITER\);
LINE = PACKED RECORD
%DESCRIPTION THE LINE NUMBER\
LINENR : LINENRTY; %LINE NUMBER\
PAGENR : PAGENRTY; %PAGE NUMBER\
CONTLINK : LINEPTRTY %NEXT LINE NUMBER RECORD\
END;
LIST = PACKED RECORD
%DESCRIPTION OF IDENTIFIERS\
NAME : WORD; %NAME OF THE IDENTIFIER\
LLINK , %LEFT SUCCESSOR IN TREE\
RLINK : LISTPTRTY; %RIGHT SUCCESSOR IN TREE\
FIRST , %POINTER TO FIRST LINE NUMBER RECORD\
LAST : LINEPTRTY; %POINTER TO LAST LINE NUMBER RECORD\
PROCVAR : ROUTINFO;
CALLED, %POINTS TO THE FIRST PROCEDURE CALLED BY THIS ONE\
CALLEDBY : PROCCALLTY %POINTER TO FIRST CALLING PROCEDURE\
END;
PROCCALL = PACKED RECORD
%DESCRIPTION OF PROCEDURE CALLS\
PROCNAME : LISTPTRTY; %POINTER TO THE APPROPRIATE IDENTIFIER RECORD\
NEXTPROC : PROCCALLTY; %POINTER TO THE NEXT PROCEDURE\
FIRST, %LINE NUMBER RECORD FOR THE FIRST CALL\
LAST : LINEPTRTY %LINE NUMBER RECORD FOR THE LAST CALL\
END;
DBLEDECLIST = ↑DOUBLEDEC;
DOUBLEDEC = PACKED RECORD
%PROCEDURES WHICH ARE ALSO DEFINED AS NORMAL IDENTIFIERS\
PROCORT : LISTPTRTY; %POINTER TO THE PROCEDURE\
NEXTPROC: DBLEDECLIST %NEXT DOUBLY DECLARED PROCEDURE\
END;
PROCSTRUC = PACKED RECORD
%DESCRIPTION OF THE PROCEDURE NESTING\
PROCNAME : LISTPTRTY; %POINTER TO THE APPROPRIATE IDENTIFIER\
NEXTPROC : PROCSTRUCTY; %POINTER TO THE NEXT ELEMENT\
LINENR : LINENRTY; %LINE NUMBER OF THE PROCEDURE DEFINITION\
PAGENR , %PAGE NUMBER OF THE PROCEDURE DEFINITION\
PROCLEVEL: PAGENRTY %NESTING DEPTH OF THE PROCEDURE\
END;
VAR
FEED, %INDENTATION BY PROCEDURES AND BLOCKS\
I, %INDEX VARIABLE\
BUFFLEN, %LENGTH OF THE CURRENT LINE IN THE INPUT BUFFER\
BUFFMARK, %LENGTH OF THE ALREADY PRINTED PART OF THE BUFFER\
BUFFERPTR, %POINTER TO THE NEXT CHARACTER IN THE BUFFER\
BUFFINDEX, %CHARACTER COUNTER FOR BUFF\
BMARKNR, %NUMBER FOR MARKING OF 'BEGIN', 'LOOP' ETC.\
EMARKNR, %NUMBER FOR MARKING OF 'END', 'UNTIL' ETC.\
SPACES, %INDENTATION FOR THE FORMATTING\
LASTSPACES, %ONE-TIME OVERRIDING VALUE FOR SPACES\
SYLENG, %LENGTH OF THE LAST READ IDENTIFIER OR LABEL\
LEVEL, %NESTING DEPTH OF THE CURRENT PROCEDURE\
BLOCKNR, %COUNTS THE STATEMENTS 'BEGIN', 'CASE', 'LOOP', 'REPEAT', 'IF'\
PAGECNT, %COUNTS THE SOS-PAGES\
PAGECNT2, %COUNTS THE PRINT PAGES PER SOS-PAGE\
INCREMENT, %PARAMETER FOR THE INCREMENTING OF THE LINE NUMBER\
MAXINC, %GREATEST ALLOWABLE LINE NUMBER\
REALLINCNT, %COUNTS THE LINES PER PRINT PAGE\
LINECNT : INTEGER; %COUNTS THE LINES PER SOS-PAGE\
PROCDEC: ROUTINFO;
INPUTFILE, %DESCRIPTION OF THE INPUT FILE\
OUTPUTFILE : RECORD
%DESCRIPTION OF THE OUTPUT FILE\
FILENAME : PACKED ARRAY [1..9] OF CHAR;
DEVICE : PACKED ARRAY [1..6] OF CHAR;
PPN : INTEGER;
PROT : 0..777B
END;
PROCSTRUCDATA : RECORD
%NEXT PROCEDURE TO BE PUT IN NESTING LIST\
CASE EXISTS : BOOLEAN OF
TRUE : (ITEM : PROCSTRUC)
END;
BUFFER : ARRAY [-1..148] OF CHAR; %INPUT BUFFER (147 CHARACTERS = MAX. LENGTH SOS-LINE)\
%BUFFER HAS 2 EXTRA POSITIONS ON THE LEFT AND ONE ON THE RIGHT\
LINENB : PACKED ARRAY [1..5] OF CHAR; %SOS-LINE NUMBER\
TIMEANDDAY : PACKED ARRAY [1..24] OF CHAR; %HEADING DATE AND TIME\
SY : WORD; %LAST SYMBOL READ\
SYTY : SYMBOL; %TYPE OF THE LAST SYMBOL READ\
FAST, %IF TRUE, MAKE NO LISTING FILE\
SEQUENCE, %IF TRUE, LINE NUMBERS ARE OUTPUT TO 'NEW' FILE\
THENDO, %SET WHENEVER 'SPACES := SPACES+DOFEED' IS EXECUTED\
FWDDECL, %SET TRUE BY BLOCK AFTER 'FORWARD', 'EXTERN'\
ERRFLAG, %SET IF AN ERROR IS DETECTED\
OLDSPACES, %SET WHEN LASTSPACES SHOULD BE USED\
EOLINE, %SET AT END ON INPUT LINE\
GOTOINLINE, %SET IF A HORRENDOUS GOTO STATEMENT IN THIS LINE\
EOB : BOOLEAN; %EOF-FLAG\
CH, %LAST READ CHARACTER\
BMARKTEXT, %CHARACTER FOR MARKING OF 'BEGIN' ETC.\
EMARKTEXT: CHAR; %CHARACTER FOR MARKING OF 'END' ETC.\
DELSY : ARRAY [' '..'←'] OF SYMBOL; %TYPE ARRAY FOR DELIMITER CHARACTERS\
RESNUM : ARRAY ['A'..'['] OF INTEGER; %INDEX OF THE FIRST KEYWORD BEGINNING WITH THE INDEXED LETTER\
RESLIST : ARRAY [1..46] OF WORD; %LIST OF THE RESERVED WORDS\
RESSY : ARRAY [1..46] OF SYMBOL; %TYPE ARRAY OF THE RESERVED WORDS\
ALPHANUM, %CHARACTERS FROM 0..9 AND A..Z\
DIGITS, %CHARACTERS FROM 0..9\
LETTERS : SET OF CHAR; %CHARACTERS FROM A..Z\
RELEVANTSYM, %START SYMBOLS FOR STATEMENTS AND PROCEDURES\
PROSYM, %ALL SYMBOLS WHICH BEGIN A PROCEDURE\
DECSYM, %ALL SYMBOLS WHICH BEGIN DECLARATIONS\
BEGSYM, %ALL SYMBOLS WHICH BEGIN COMPOUND STATEMENTS\
ENDSYM : SET OF SYMBOL; %ALL SYMBOLS WHICH TERMINATE STATEMENTS OR PROCEDURES\
LISTPTR : LISTPTRTY; %POINTER INTO THE BINARY TREE OF THE IDENTIFIER\
FIRSTNAME : ARRAY ['A'..'Z'] OF LISTPTRTY; %POINTER TO THE ROOTS OF THE TREE\
PROCSTRUCF, %POINTER TO THE FIRST ELEMENT OF THE PROCEDURE CALLS LIST\
PROCSTRUCL : PROCSTRUCTY; %POINTER TO THE LAST ELEMENT OF THE PROCEDURE CALLS LIST\
NEWFIL : TEXT; %OUTPUT FILE ONTO WHICH THE 'NEW' FILE IS WRITTEN\
MESSAGE : PACKED ARRAY [1..23] OF CHAR; %COMPLETION MESSAGE\
INITPROCEDURE;
BEGIN
RESNUM['A'] := 1;
RESNUM['B'] := 4;
RESNUM['C'] := 6;
RESNUM['D'] := 10;
RESNUM['E'] := 13;
RESNUM['F'] := 17;
RESNUM['G'] := 22;
RESNUM['H'] := 23;
RESNUM['I'] := 23;
RESNUM['J'] := 27;
RESNUM['K'] := 27;
RESNUM['L'] := 27;
RESNUM['M'] := 29;
RESNUM['N'] := 29;
RESNUM['O'] := 31;
RESNUM['P'] := 34;
RESNUM['Q'] := 36;
RESNUM['R'] := 36;
RESNUM['S'] := 39;
RESNUM['T'] := 40;
RESNUM['U'] := 43;
RESNUM['V'] := 44;
RESNUM['W'] := 45;
RESNUM['X'] := 47;
RESNUM['Y'] := 47;
RESNUM['Z'] := 47;
RESNUM['['] := 47;
RESLIST[ 1] :='ALGOL '; RESSY [ 1] := LANGSY;
RESLIST[ 2] :='AND '; RESSY [ 2] := OTHERSY;
RESLIST[ 3] :='ARRAY '; RESSY [ 3] := OTHERSY;
RESLIST[ 4] :='BEGIN '; RESSY [ 4] := BEGINSY;
RESLIST[ 5] :='BOOLEAN '; RESSY [ 5] := OTHERSY;
RESLIST[ 6] :='CHAR '; RESSY [ 6] := OTHERSY;
RESLIST[ 7] :='CASE '; RESSY [ 7] := CASESY;
RESLIST[ 8] :='CONST '; RESSY [ 8] := CONSTSY;
RESLIST[ 9] :='COBOL '; RESSY [ 9] := LANGSY;
RESLIST[10] :='DO '; RESSY [10] := DOSY;
RESLIST[11] :='DIV '; RESSY [11] := OTHERSY;
RESLIST[12] :='DOWNTO '; RESSY [12] := OTHERSY;
RESLIST[13] :='END '; RESSY [13] := ENDSY;
RESLIST[14] :='ELSE '; RESSY [14] := ELSESY;
RESLIST[15] :='EXIT '; RESSY [15] := EXITSY;
RESLIST[16] :='EXTERN '; RESSY [16] := EXTERNSY;
RESLIST[17] :='FOR '; RESSY [17] := OTHERSY;
RESLIST[18] :='FILE '; RESSY [18] := OTHERSY;
RESLIST[19] :='FORWARD '; RESSY [19] := FORWARDSY;
RESLIST[20] :='FUNCTION '; RESSY [20] := FUNCTIONSY;
RESLIST[21] :='FORTRAN '; RESSY [21] := LANGSY;
RESLIST[22] :='GOTO '; RESSY [22] := GOTOSY;
RESLIST[23] :='IF '; RESSY [23] := IFSY;
RESLIST[24] :='IN '; RESSY [24] := OTHERSY;
RESLIST[25] :='INTEGER '; RESSY [25] := OTHERSY;
RESLIST[26] :='INITPROCED'; RESSY [26] := INITPROCSY;
RESLIST[27] :='LOOP '; RESSY [27] := LOOPSY;
RESLIST[28] :='LABEL '; RESSY [28] := LABELSY;
RESLIST[29] :='NOT '; RESSY [29] := OTHERSY;
RESLIST[30] :='NIL '; RESSY [30] := OTHERSY;
RESLIST[31] :='OR '; RESSY [31] := OTHERSY;
RESLIST[32] :='OF '; RESSY [32] := OFSY;
RESLIST[33] :='OTHERS '; RESSY [33] := OTHERSSY;
RESLIST[34] :='PACKED '; RESSY [34] := OTHERSY;
RESLIST[35] :='PROCEDURE '; RESSY [35] := PROCEDURESY;
RESLIST[36] :='REAL '; RESSY [36] := OTHERSY;
RESLIST[37] :='RECORD '; RESSY [37] := RECORDSY;
RESLIST[38] :='REPEAT '; RESSY [38] := REPEATSY;
RESLIST[39] :='SET '; RESSY [39] := OTHERSY;
RESLIST[40] :='THEN '; RESSY [40] := THENSY;
RESLIST[41] :='TO '; RESSY [41] := OTHERSY;
RESLIST[42] :='TYPE '; RESSY [42] := TYPESY;
RESLIST[43] :='UNTIL '; RESSY [43] := UNTILSY;
RESLIST[44] :='VAR '; RESSY [44] := VARSY;
RESLIST[45] :='WHILE '; RESSY [45] := OTHERSY;
RESLIST[46] :='WITH '; RESSY [46] := OTHERSY;
END;
INITPROCEDURE;
BEGIN
MESSAGE := 'ERROR IN BLOCKSTRUCTURE';
DIGITS := ['0'..'9'];
LETTERS := ['A'..'Z'];
ALPHANUM := ['0'..'9','A'..'Z'] %LETTERS OR DIGITS\;
DECSYM := [LABELSY..VARSY];
PROSYM := [FUNCTIONSY..INITPROCSY];
ENDSYM := [FUNCTIONSY..EOBSY]; %PROSYM OR ENDSYMBOLS\
BEGSYM := [BEGINSY..IFSY];
RELEVANTSYM := [LABELSY..INITPROCSY %DECSYM OR PROSYM\,BEGINSY,FORWARDSY,EXTERNSY,EOBSY];
END;
PROCEDURE INIT;
BEGIN (*INIT*)
I := 0;
FEED := 4;
BUFFLEN := 0;
BUFFMARK := 0;
BUFFERPTR := 2;
BUFFINDEX := 0;
REALLINCNT:= 0;
LINECNT :=0;
BLOCKNR := 0;
LEVEL := 0;
PAGECNT := 1;
PAGECNT2 := 0;
SEQUENCE := TRUE;
FAST := FALSE;
INCREMENT := 100;
EOB := FALSE;
ERRFLAG := FALSE;
EOLINE := TRUE;
GOTOINLINE := FALSE;
PROCSTRUCDATA.EXISTS := FALSE;
OLDSPACES := FALSE;
CH := ' ';
BMARKTEXT := ' ';
EMARKTEXT := ' ';
SY := ' ';
TIMEANDDAY := ' : : ';
FOR CH := 'A' TO 'Z' DO FIRSTNAME [CH] := NIL;
FOR CH := ' ' TO '←' DO DELSY [CH] := OTHERSY;
DELSY ['('] := LPARENT;
DELSY [')'] := RPARENT;
DELSY ['['] := LPARENT;
DELSY [']'] := RPARENT;
DELSY [';'] := SEMICOLON;
DELSY ['.'] := POINT;
DELSY [':'] := COLON;
FOR I := -1 TO 148 DO BUFFER [I] := ' ';
I := 0;
NEW (FIRSTNAME['M']);
LISTPTR := FIRSTNAME ['M'];
WITH FIRSTNAME ['M']↑ DO BEGIN
NAME := 'MAIN. ';
LLINK := NIL;
RLINK := NIL;
NEW (FIRST);
LAST := FIRST;
PROCVAR := PROC;
WITH LAST↑ DO BEGIN
LINENR := LINECNT;
CONTLINK := NIL;
END;
NEW (CALLED);
WITH CALLED↑ DO BEGIN
PROCNAME := FIRSTNAME ['M'];
NEXTPROC := NIL;
NEW (FIRST);
FIRST↑.LINENR := 0;
FIRST↑.CONTLINK := NIL;
LAST := FIRST;
END;
NEW (CALLEDBY);
WITH CALLEDBY↑ DO BEGIN
PROCNAME := FIRSTNAME ['M'];
NEXTPROC := NIL;
NEW (FIRST);
FIRST↑.LINENR := 0;
FIRST↑.CONTLINK := NIL;
LAST := FIRST;
END;
END;
NEW (PROCSTRUCF);
WITH PROCSTRUCF↑ DO BEGIN
PROCNAME := FIRSTNAME ['M'];
NEXTPROC := NIL;
LINENR := 0;
PROCLEVEL:= 0;
END;
PROCSTRUCL := PROCSTRUCF;
END %INIT\;
PROCEDURE DATUM;
%SET UP TIME AND DATE\
VAR
DATUM : PACKED ARRAY [1..9] OF CHAR;
HOUR,MIN,SEC,I : INTEGER;
BEGIN
(*DATE(DATUM);****************************** *)
FOR I := 1 TO 9 DO TIMEANDDAY[I] := DATUM[I];
(**********TIME(I);*************** *)
I := I DIV 1000;
HOUR := I DIV 3600;
I := I MOD 3600;
MIN := I DIV 60;
SEC := I MOD 60;
TIMEANDDAY[17] := CHR (60B+HOUR DIV 10);
TIMEANDDAY[18] := CHR (60B+HOUR MOD 10);
TIMEANDDAY[20] := CHR (60B+MIN DIV 10);
TIMEANDDAY[21] := CHR (60B+MIN MOD 10);
TIMEANDDAY[23] := CHR (60B+SEC DIV 10);
TIMEANDDAY[24] := CHR (60B+SEC MOD 10);
END;
PROCEDURE HEADER;
%PRINT TOP OF FORM AND HEADER ON LIST OUTPUT\
BEGIN %HEADER\
PAGECNT2 := PAGECNT2 + 1;
REALLINCNT := 0;
IF NOT FAST THEN BEGIN
PAGE;
WRITELN ('PAGE ':20,PAGECNT:3,'-',PAGECNT2:3,' ':15,OUTPUTFILE.FILENAME:6,
' ':9,TIMEANDDAY);
WRITELN
END;
END %HEADER\;
PROCEDURE NEWPAGE;
BEGIN %NEWPAGE\
PAGECNT2 := 0;
PAGECNT := PAGECNT + 1;
WRITE(NEWFIL, CHR(CR), CHR(FF));
HEADER;
IF EOLN (INPUT) THEN READLN;
LINECNT := 0;
REALLINCNT := 0;
END %NEWPAGE\;
PROCEDURE NEWLINE;
BEGIN
IF REALLINCNT = MAXLINE THEN HEADER;
LINECNT := LINECNT + 1;
REALLINCNT := REALLINCNT + 1;
%IF SEQUENCE THEN PUTLINNR...\
END;
PROCEDURE WRTELINE (POSITION %LETZTES ZU DRUCKENDES ZEICHEN IM PUFFER\: INTEGER);
VAR
I, J, TABCNT, LSPACES : INTEGER; %MARKIERT ERSTES ZU DRUCKENDES ZEICHEN\
BEGIN %WRTELINE\
POSITION := POSITION - 2;
IF POSITION > 0 THEN BEGIN
I := BUFFMARK + 1;
WHILE (BUFFER [I] = ' ') AND (I <= POSITION) DO I := I + 1;
BUFFMARK := POSITION;
WHILE (BUFFER [POSITION] = ' ') AND (I < POSITION) DO POSITION := POSITION - 1;
IF I <= POSITION THEN BEGIN
NEWLINE;
IF NOT FAST THEN BEGIN
IF GOTOINLINE THEN BEGIN
WRITE('****GOTO****');
GOTOINLINE := FALSE;
END
ELSE IF BMARKTEXT # ' ' THEN BEGIN
WRITE (BMARKTEXT, BMARKNR : 4, ' ');
BMARKTEXT := ' ';
END
ELSE IF EMARKTEXT # ' ' THEN BEGIN
WRITE (' ',EMARKTEXT,EMARKNR : 4,' ');
EMARKTEXT := ' ';
END
ELSE WRITE (CHR(HT),' ');
WRITE (LINECNT * INCREMENT : 5,' ');
END;
IF NOT OLDSPACES THEN LASTSPACES := SPACES;
%USE TABS AND SPACES TO MAKE INDENTATION\
TABCNT := LASTSPACES DIV 8;
LSPACES := LASTSPACES MOD 8;
FOR TABCNT := TABCNT DOWNTO 1 DO BEGIN
WRITE(NEWFIL, CHR(HT)); WRITE(CHR(HT))
END;
IF NOT FAST THEN BEGIN
IF LASTSPACES > 7 THEN WRITE(' ');
%COMPENSATE FOR THE FIRST TAB, WHICH IS SHORT\
WRITE(' ': LSPACES);
END;
WRITE(NEWFIL, ' ': LSPACES);
IF (POSITION - I + LASTSPACES + 1) > MAXCH THEN BEGIN
IF REALLINCNT = MAXLINE THEN BEGIN
FOR I := I TO MAXCH + I - LASTSPACES - 1 DO BEGIN
WRITE (BUFFER[I]);
WRITE(NEWFIL, BUFFER[I]);
END;
WRITELN;
HEADER;
END;
REALLINCNT := REALLINCNT + 1;
END;
IF FAST THEN FOR J := I TO POSITION DO WRITE(NEWFIL, BUFFER[J])
ELSE BEGIN
FOR J := I TO POSITION DO BEGIN
WRITE (BUFFER [J]);
WRITE(NEWFIL, BUFFER[J]);
END;
WRITELN;
END;
WRITELN(NEWFIL);
IF ((LINENB = ' ') AND (POSITION = BUFFLEN)) OR (MAXINC <= LINECNT) THEN NEWPAGE;
END;
END;
LASTSPACES := SPACES;
OLDSPACES := FALSE;
THENDO := FALSE;
END %WRTELINE\ ;
PROCEDURE READLINE;
%HANDLES LEADING BLANKS AND BLANK LINES, READS NEXT NONBLANK LINE
(WITHOUT LEADING BLANKS) INTO BUFFER\
VAR
CH : CHAR;
BEGIN %READLINE\
%ENTERED AT THE BEGINNING OF A LINE\
REPEAT
WHILE EOLN (INPUT) AND NOT EOF (INPUT) DO BEGIN
%IS THIS A PAGE MARK?\
GETLINENR (LINENB);
READLN;
IF LINENB = ' ' THEN NEWPAGE ELSE BEGIN
%HANDLE BLANK LINE\
NEWLINE;
IF NOT FAST THEN WRITELN (CHR(HT),' ',LINECNT * INCREMENT : 5);
WRITELN(NEWFIL);
IF MAXINC <= LINECNT THEN NEWPAGE;
END;
END;
READ (CH);
UNTIL (CH # ' ') OR (EOF (INPUT));
BUFFLEN := 0;
%READ IN THE LINE\
LOOP
BUFFLEN := BUFFLEN + 1;
BUFFER [BUFFLEN] := CH;
EXIT IF (EOLN (INPUT) OR (BUFFLEN = 147));
READ (CH);
END;
BUFFER[BUFFLEN+1] := ' '; %SO WE CAN ALWAYS BE ONE CHAR AHEAD\
IF NOT EOLN (INPUT) THEN BEGIN
WRITELN (TTY);
WRITELN (TTY,'LINE ',(LINECNT+1)*INCREMENT : 5, '/', PAGECNT: 2, ' TOO LONG');
WRITELN (' ' : 17,' **** NEXT LINE TOO LONG ****');
END
ELSE IF NOT EOF (INPUT) THEN BEGIN
GETLINENR (LINENB);
READLN;
END;
BUFFERPTR := 1;
BUFFMARK := 0;
END %READLINE\ ;
PROCEDURE READBUFFER;
%READS A CHARACTER FROM THE INPUT BUFFER\
BEGIN %READBUFFER\
%IF READING PAST THE EXTRA BLANK ON THE END, GET A NEW LINE\
IF EOLINE THEN BEGIN
WRTELINE (BUFFERPTR);
CH := ' ';
IF EOF (INPUT) THEN EOB := TRUE ELSE READLINE;
END
ELSE BEGIN
CH := BUFFER [BUFFERPTR];
BUFFERPTR := BUFFERPTR + 1;
END;
EOLINE := BUFFERPTR = BUFFLEN + 2;
END %READBUFFER\ ;
FUNCTION RESWORD: BOOLEAN ;
%DETERMINES IF THE CURRENT IDENTIFIER IS A RESERVED WORD\
LABEL 1;
VAR
I: INTEGER;
BEGIN %RESWORD\
RESWORD:= FALSE;
FOR I:=RESNUM[SY[1]] TO RESNUM[SUCC(SY[1])] - 1
DO IF RESLIST[ I ] = SY THEN BEGIN
RESWORD := TRUE;
SYTY := RESSY [I];
IF SYTY = GOTOSY THEN GOTOINLINE := TRUE;
GOTO 1;
END;
1:
END %RESWORD\ ;
PROCEDURE FINDNAME(DOUBLEDECF, DOUBLEDECL: DBLEDECLIST; CURPROC: LISTPTRTY);
LABEL 1;
VAR
PROCPTR : PROCCALLTY; %ZEIGER AUF RUFENDE BZW. GERUFENE PROZEDUR BEI DEREN VERKETTUNG\
LPTR: LISTPTRTY; %ZEIGER AUF DEN VORGAENGER IM BAUM\
ZPTR : LINEPTRTY; %ZEIGER AUF DIE VORLETZTE ZEILENNUMMER IN EINER KETTE\
RIGHT: BOOLEAN; %MERKVARIABLE FUER DIE VERZWEIGUNG IM BAUM\
INDEXCH : CHAR; %INDEXVARIABLE FUER DAS FELD DER STARTZEIGER (FIRSTNAME)\
PROCEDURE FINDPROC (COMP : LISTPTRTY);
%BUILDS UP THE LISTS OF CALLEDBY AND CALLED\
VAR
PROCCALLPTR : PROCCALLTY; %MERK SICH LETZTE PROZEDUR FALLS EINE NEUE ERZEUGT WERDEN MUSS\
BEGIN %FINDPROC\
WHILE (PROCPTR↑.PROCNAME # COMP) AND (PROCPTR↑.NEXTPROC # NIL) DO
PROCPTR := PROCPTR↑.NEXTPROC;
IF PROCPTR↑.PROCNAME = COMP THEN BEGIN
ZPTR := PROCPTR↑.LAST;
IF (ZPTR↑.LINENR # LINECNT+1) OR (ZPTR↑.PAGENR # PAGECNT) THEN BEGIN
NEW (PROCPTR↑.LAST);
WITH PROCPTR↑.LAST↑ DO BEGIN
LINENR := LINECNT + 1;
PAGENR := PAGECNT;
CONTLINK := NIL;
END;
ZPTR↑.CONTLINK := PROCPTR↑.LAST;
END;
END
ELSE BEGIN
PROCCALLPTR := PROCPTR;
NEW (PROCPTR);
WITH PROCPTR↑ DO BEGIN
PROCNAME := COMP;
NEXTPROC := NIL;
NEW (FIRST);
WITH FIRST↑ DO BEGIN
LINENR := LINECNT + 1;
PAGENR := PAGECNT;
CONTLINK := NIL;
END;
LAST := FIRST;
END;
PROCCALLPTR↑.NEXTPROC := PROCPTR;
END;
END %FINDPROC\ ;
PROCEDURE NEWPROCEDURE;
BEGIN %NEWPROCEDURE\
WITH LISTPTR↑ DO BEGIN
PROCVAR := PROCDEC;
NEW (CALLEDBY);
WITH CALLEDBY↑ DO BEGIN
PROCNAME := CURPROC;
NEXTPROC := NIL;
NEW (FIRST);
WITH FIRST↑ DO BEGIN
LINENR := LINECNT + 1;
PAGENR := PAGECNT;
CONTLINK := NIL;
END;
LAST := FIRST;
END;
NEW (CALLED);
WITH CALLED↑ DO BEGIN
PROCNAME := FIRSTNAME ['M'];
NEXTPROC := NIL;
NEW (FIRST);
WITH FIRST↑ DO BEGIN
LINENR := LINECNT + 1;
PAGENR := PAGECNT;
CONTLINK := NIL;
END;
LAST := FIRST;
END;
END;
END %NEWPROCEDURE\ ;
BEGIN %FINDNAME\
INDEXCH := SY [1];
LISTPTR := FIRSTNAME [INDEXCH];
%SEARCH IN THE TREE FOR THE IDENTIFIER\
WHILE LISTPTR # NIL DO BEGIN
LPTR:= LISTPTR;
IF SY = LISTPTR↑.NAME THEN BEGIN
ZPTR := LISTPTR↑.LAST;
IF (ZPTR↑.LINENR # LINECNT+1) OR (ZPTR↑.PAGENR # PAGECNT) THEN BEGIN
NEW (LISTPTR↑.LAST);
WITH LISTPTR↑.LAST↑ DO BEGIN
LINENR := LINECNT + 1;
PAGENR := PAGECNT;
CONTLINK := NIL;
END;
ZPTR↑.CONTLINK := LISTPTR↑.LAST;
END;
IF LISTPTR↑.PROCVAR # NOTROUT THEN BEGIN
IF LISTPTR↑.PROCVAR = FUNC THEN WHILE CH = ' ' DO BEGIN
SYLENG := SYLENG + 1;
READBUFFER;
END;
%IF A PROCEDURE OR FUNCTION CALL, INCLUDE IT IN CALLING LISTS\
IF (CH # ':') OR (LISTPTR↑.PROCVAR = PROC) THEN BEGIN
PROCPTR := LISTPTR↑.CALLEDBY;
FINDPROC (CURPROC);
PROCPTR := CURPROC↑.CALLED;
FINDPROC (LISTPTR);
END
END
ELSE IF PROCDEC # NOTROUT THEN BEGIN
IF DOUBLEDECF = NIL THEN BEGIN
NEW (DOUBLEDECF);
DOUBLEDECL := DOUBLEDECF;
END
ELSE BEGIN
NEW (DOUBLEDECL↑.NEXTPROC);
DOUBLEDECL := DOUBLEDECL↑.NEXTPROC;
END;
DOUBLEDECL↑.NEXTPROC := NIL;
DOUBLEDECL↑.PROCORT := LISTPTR;
NEWPROCEDURE;
END;
GOTO 1;
END
ELSE IF SY > LISTPTR↑.NAME THEN BEGIN
LISTPTR:= LISTPTR↑.RLINK;
RIGHT:= TRUE;
END
ELSE BEGIN
LISTPTR:= LISTPTR↑.LLINK;
RIGHT:= FALSE;
END;
END;
%IF CONTROL COMES HERE, THE IDENTIFIER IS UNKNOWN\
NEW (LISTPTR);
WITH LISTPTR↑ DO BEGIN
NAME := SY;
LLINK := NIL;
RLINK := NIL;
END;
IF FIRSTNAME [INDEXCH] = NIL THEN FIRSTNAME [INDEXCH] := LISTPTR
ELSE IF RIGHT THEN LPTR↑.RLINK := LISTPTR ELSE LPTR↑.LLINK := LISTPTR;
WITH LISTPTR↑ DO BEGIN
NEW (FIRST);
WITH FIRST↑ DO BEGIN
LINENR := LINECNT + 1;
PAGENR := PAGECNT;
CONTLINK := NIL;
END;
LAST := FIRST ;
IF PROCDEC = NOTROUT THEN BEGIN
PROCVAR := NOTROUT;
CALLED := NIL;
CALLEDBY := NIL;
END
ELSE NEWPROCEDURE;
END;
1:
PROCDEC := NOTROUT;
END %FINDNAME\ ;
PROCEDURE BLOCK;
VAR
DOUBLEDECF, %ZEIGER AUF ERSTE UND LETZTE VARIABLE DIE ALS PROCEDURE\
DOUBLEDECL : DBLEDECLIST; %IN DIESEM BLOCK DOPPELT DEKLARIERT WURDEN\
CURPROC : LISTPTRTY; %ZEIGER AUF DIE PROZEDUR IN DEREN ANWEISUNGSTEIL DAS PROGRAMM SICH BEFINDET\
PROCEDURE ERROR (ERRNR : ERRKINDS);
BEGIN %ERROR\
ERRFLAG := TRUE;
REALLINCNT := REALLINCNT + 1; %COUNT THE LINE OF THE ERROR MESSAGE ON THE LPT: FILE\
WRITE (' ':17,' **** ');
CASE ERRNR OF
ERRINBLKSTR : WRITELN(SY,' ? ? ? ',MESSAGE);
MISSGENDUNTIL : WRITELN('MISSING ''END'' OR ''UNTIL'' NUMBER ',EMARKNR : 4);
MISSGTHEN : WRITELN('MISSING ''THEN'' NUMBER ',EMARKNR : 4);
MISSGOF : WRITELN('MISSING ''OF'' TO ''CASE'' NUMBER ',BMARKNR : 4);
MISSGEXIT : WRITELN('MISSING ''EXIT'' IN ''LOOP'' ',EMARKNR : 4);
MISSGRPAR : WRITELN('MISSING RIGHT PARENTHESIS');
MISSGQUOTE : WRITELN('MISSING CLOSING QUOTE ON THIS LINE')
END;
WRITELN(TTY, 'ERROR AT ', LINECNT*INCREMENT: 5, '/', PAGECNT:2);
END %ERROR\ ;
PROCEDURE NEWLINEHERE;
BEGIN
WRTELINE(BUFFERPTR - SYLENG);
END;
PROCEDURE SETLASTSPACES(I: INTEGER);
BEGIN
OLDSPACES := TRUE;
LASTSPACES := I;
END;
PROCEDURE MAYBESLS(I: INTEGER);
BEGIN
IF NOT OLDSPACES THEN SETLASTSPACES(I);
END;
PROCEDURE INSYMBOL ;
LABEL 1;
VAR
OLDSPACESMARK, %ALTER ZEICHENVORSCHUB BEI FORMATIERUNG VON KOMMENTAREN\
I : INTEGER;
PROCEDURE PARENTHESE;
VAR
OLDSPACESMARK : INTEGER; %ALTER ZEICHENVORSCHUB BEI FORMATIERUNG VON KLAMMERN\
BEGIN %PARENTHESE\
OLDSPACESMARK := SPACES;
MAYBESLS(SPACES);
SPACES := LASTSPACES + BUFFERPTR - BUFFMARK - 2;
%SKIP STUFF UNTIL WE SEEM TO BE OUT OF THE EXPRESSION\
REPEAT
INSYMBOL
UNTIL SYTY IN [EXTERNSY..RPARENT,LABELSY..TYPESY,INITPROCSY..EXITSY,DOSY..FORWARDSY];
SPACES := OLDSPACESMARK;
OLDSPACES := TRUE;
IF SYTY = RPARENT THEN INSYMBOL ELSE ERROR(MISSGRPAR);
END %PARENTHESE\ ;
BEGIN %INSYMBOL\
SYLENG := 0;
WHILE (CH IN ['←','(',' ','%','$','?','\','!','@']) AND NOT EOB DO BEGIN
IF (CH = '%') OR (CH = '(') AND (BUFFER[BUFFERPTR] = '*') THEN BEGIN
OLDSPACESMARK := SPACES;
IF OLDSPACES THEN SPACES := LASTSPACES ELSE LASTSPACES := SPACES;
SPACES := SPACES + BUFFERPTR - 1;
OLDSPACES := TRUE;
IF CH = '%' THEN REPEAT
READBUFFER;
UNTIL (CH = '\') OR EOB
ELSE REPEAT
READBUFFER
UNTIL (CH = ')') AND (BUFFER[BUFFERPTR-2] = '*') OR EOB;
SPACES := OLDSPACESMARK;
OLDSPACES := TRUE;
END
ELSE IF CH = '(' THEN GOTO 1;
READBUFFER;
END;
CASE CH OF
'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I',
'J', 'K', 'L', 'M', 'N', 'O', 'P', 'Q',
'R', 'S', 'T', 'U', 'V', 'W', 'X', 'Y',
'Z':
BEGIN
SYLENG := 0;
SY := ' ';
REPEAT
SYLENG := SYLENG + 1;
IF SYLENG <= 10 THEN SY [SYLENG] := CH;
READBUFFER;
UNTIL NOT (CH IN (ALPHANUM + ['←']));
IF NOT RESWORD THEN BEGIN
SYTY := IDENT ;
FINDNAME(DOUBLEDECF, DOUBLEDECL, CURPROC);
END
END;
'0', '1', '2', '3', '4', '5', '6', '7', '8',
'9':
BEGIN
REPEAT
SYLENG := SYLENG + 1;
READBUFFER;
UNTIL NOT (CH IN DIGITS);
SYTY := INTCONST;
IF CH = 'B' THEN READBUFFER ELSE BEGIN
IF CH = '.' THEN BEGIN
REPEAT
READBUFFER
UNTIL NOT (CH IN DIGITS);
SYTY := OTHERSY; SYLENG := 0; %REALS CAN'T BE LABELS\
END;
IF CH = 'E' THEN BEGIN
READBUFFER;
IF CH IN ['+','-'] THEN READBUFFER;
WHILE CH IN DIGITS DO READBUFFER;
SYTY := OTHERSY; SYLENG := 0; %REALS CAN'T BE LABELS\
END;
END;
END;
'''':
BEGIN
SYTY := STRGCONST;
REPEAT
READBUFFER;
UNTIL (CH = '''') OR EOB OR EOLINE;
IF CH # '''' THEN ERROR(MISSGQUOTE);
READBUFFER;
END;
'"':
BEGIN
REPEAT
READBUFFER
UNTIL NOT (CH IN (DIGITS + ['A'..'F']));
SYTY := INTCONST;
END;
' ': SYTY := EOBSY; %END OF FILE\
OTHERS:
BEGIN
1:
SYTY := DELSY [CH];
READBUFFER;
IF SYTY = LPARENT THEN PARENTHESE ELSE IF (SYTY = COLON) AND (CH = '=') THEN BEGIN
SYTY := OTHERSY;
READBUFFER;
END;
END
END;
END %INSYMBOL\ ;
PROCEDURE RECDEF;
VAR
OLDSPACESMARK : INTEGER; %ALTER ZEICHENVORSCHUB BEI FORMATIERUNG VON RECORDS\
PROCEDURE CASEDEF;
VAR
OLDSPACESMARK : INTEGER; %ALTER ZEICHENVORSCHUB BEI FORMATIERUNG VON VARIANT PARTS\
PROCEDURE PARENTHESE;
%HANDLES THE FORMATTING OF PARENTHESES INSIDE VARIANT PARTS\
VAR
OLDSPACESMARK : INTEGER; %SAVED VALUE OF 'SPACES'\
BEGIN %PARENTHESE\
OLDSPACESMARK := SPACES;
MAYBESLS(SPACES);
SPACES := SPACES + BUFFERPTR - 2;
INSYMBOL;
REPEAT
CASE SYTY OF
CASESY :
BEGIN
CASEDEF; DELSY['('] := LBRACK
END;
RECORDSY : RECDEF;
OTHERS: INSYMBOL
END;
%UNTIL WE APPARENTLY LEAVE THE DECLARATION\
UNTIL SYTY IN [STRGCONST..RPARENT,LABELSY..EXITSY,DOSY..BEGINSY,
LOOPSY..FORWARDSY];
SPACES := OLDSPACESMARK;
OLDSPACES := TRUE;
IF SYTY = RPARENT THEN INSYMBOL ELSE ERROR(MISSGRPAR);
END %PARENTHESE\ ;
BEGIN %CASEDEF\
%PREVENT THE OTHER 'PARENTHESE' FROM BEING CALLED ON '('\
DELSY ['('] := LBRACK;
OLDSPACESMARK := SPACES;
MAYBESLS(SPACES);
SPACES := BUFFERPTR - BUFFMARK + LASTSPACES - SYLENG + 3;
INSYMBOL;
REPEAT
IF SYTY = LBRACK THEN PARENTHESE ELSE INSYMBOL
UNTIL SYTY IN [UNTILSY..EXITSY,LABELSY..ENDSY,RPARENT,DOSY..BEGINSY];
SPACES := OLDSPACESMARK;
DELSY ['('] := LPARENT;
END %CASEDEF\ ;
BEGIN %RECDEF\
OLDSPACESMARK := SPACES;
SETLASTSPACES(SPACES);
SPACES := BUFFERPTR - BUFFMARK + SPACES - SYLENG - 2 + FEED;
INSYMBOL;
NEWLINEHERE;
REPEAT
CASE SYTY OF
CASESY : CASEDEF;
RECORDSY : RECDEF;
OTHERS : INSYMBOL
END;
UNTIL SYTY IN [UNTILSY..EXITSY,LABELSY..ENDSY,DOSY..BEGINSY];
NEWLINEHERE;
OLDSPACES := TRUE;
LASTSPACES := SPACES - FEED;
SPACES := OLDSPACESMARK;
IF SYTY = ENDSY THEN INSYMBOL ELSE ERROR(MISSGENDUNTIL);
END %RECDEF\ ;
PROCEDURE STATEMENT;
VAR
OLDSPACESMARK, %SPACES AT ENTRY OF THIS PROCEDURE\
CURBLOCKNR : INTEGER; %AKTUELLE BLOCKNUMMER\
PROCEDURE COMPSTAT;
BEGIN %COMPSTAT\
BMARKTEXT := 'B';
MAYBESLS(SPACES - FEED);
INSYMBOL;
NEWLINEHERE;
LOOP
LOOP
STATEMENT;
EXIT IF SYTY # SEMICOLON;
INSYMBOL
END;
EXIT IF SYTY IN [ENDSY,EOBSY,PROCEDURESY,FUNCTIONSY];
ERROR (ERRINBLKSTR);
IF NOT (SYTY IN BEGSYM) THEN INSYMBOL ;
END;
NEWLINEHERE;
EMARKTEXT := 'E';
EMARKNR := CURBLOCKNR;
SETLASTSPACES(SPACES-FEED);
IF SYTY = ENDSY THEN BEGIN
INSYMBOL ;
NEWLINEHERE;
END
ELSE ERROR (MISSGENDUNTIL);
END %COMPSTAT\ ;
PROCEDURE CASESTAT;
VAR
OLDSPACESMARK : INTEGER; %SAVED VALUE OF 'SPACES'\
BEGIN %CASESTAT\
BMARKTEXT := 'C';
MAYBESLS(SPACES-FEED);
INSYMBOL;
STATEMENT;
IF SYTY = OFSY THEN WRTELINE (BUFFERPTR) ELSE ERROR (MISSGOF);
LOOP
REPEAT
REPEAT
INSYMBOL
UNTIL SYTY IN [COLON,FUNCTIONSY..EOBSY];
IF SYTY = COLON THEN BEGIN
OLDSPACESMARK := SPACES;
LASTSPACES := SPACES;
SPACES := BUFFERPTR - BUFFMARK + SPACES - 2;
OLDSPACES := TRUE;
INSYMBOL;
STATEMENT;
SPACES := OLDSPACESMARK;
END;
UNTIL SYTY IN ENDSYM;
EXIT IF SYTY IN [ENDSY,EOBSY,PROCEDURESY,FUNCTIONSY];
ERROR (ERRINBLKSTR);
END;
NEWLINEHERE;
EMARKTEXT := 'E';
EMARKNR := CURBLOCKNR;
LASTSPACES := SPACES-FEED;
OLDSPACES := TRUE;
IF SYTY = ENDSY THEN BEGIN
INSYMBOL ;
NEWLINEHERE;
END
ELSE ERROR (MISSGENDUNTIL);
END %CASESTAT\ ;
PROCEDURE LOOPSTAT;
BEGIN %LOOPSTAT\
BMARKTEXT := 'L';
MAYBESLS(SPACES - FEED);
INSYMBOL;
NEWLINEHERE;
LOOP
STATEMENT;
EXIT IF SYTY # SEMICOLON;
INSYMBOL
END;
IF SYTY = EXITSY THEN BEGIN
NEWLINEHERE;
OLDSPACES := TRUE;
LASTSPACES := SPACES-FEED;
EMARKTEXT := 'X';
EMARKNR := CURBLOCKNR;
INSYMBOL; INSYMBOL;
END
ELSE ERROR(MISSGEXIT);
LOOP
LOOP
STATEMENT;
EXIT IF SYTY # SEMICOLON;
INSYMBOL
END;
EXIT IF SYTY IN [ENDSY,EOBSY,PROCEDURESY,FUNCTIONSY];
ERROR (ERRINBLKSTR);
IF NOT (SYTY IN BEGSYM) THEN INSYMBOL ;
END;
NEWLINEHERE;
EMARKTEXT := 'E';
EMARKNR := CURBLOCKNR;
LASTSPACES := SPACES-FEED;
OLDSPACES := TRUE;
IF SYTY = ENDSY THEN BEGIN
INSYMBOL ;
NEWLINEHERE;
END
ELSE ERROR (MISSGENDUNTIL);
END %LOOPSTAT\ ;
PROCEDURE IFSTAT;
VAR
OLDSPACESMARK: INTEGER;
BEGIN %IFSTAT\
OLDSPACESMARK := SPACES;
BMARKTEXT := 'I';
MAYBESLS(SPACES - FEED); %DON'T INDENT THE 'IF'\
%MAKE 'THEN' AND 'ELSE' LINE UP WITH 'IF' UNLESS ON SAME LINE\
SPACES := LASTSPACES + BUFFERPTR - BUFFMARK + FEED - 4;
INSYMBOL;
STATEMENT; %WILL EAT THE EXPRESSION AND STOP ON A KEYWORD\
IF SYTY = THENSY THEN BEGIN
MAYBESLS(SPACES-FEED);
THENDO := TRUE; %SUPPRESS FURTHER INDENTATION FROM A 'DO'\
EMARKTEXT := 'T';
EMARKNR := CURBLOCKNR;
INSYMBOL;
STATEMENT;
END
ELSE ERROR (MISSGTHEN);
IF SYTY = ELSESY THEN BEGIN
EMARKTEXT := 'S';
EMARKNR := CURBLOCKNR;
MAYBESLS(SPACES-FEED);
THENDO := TRUE;
INSYMBOL;
STATEMENT;
END;
OLDSPACES := TRUE; %PRESERVE INDENTATION OF STATEMENT\
NEWLINEHERE;
SPACES := OLDSPACESMARK;
END %IFSTAT\ ;
PROCEDURE LABELSTAT;
BEGIN %LABELSTAT\
LASTSPACES := LEVEL * FEED;
OLDSPACES := TRUE;
INSYMBOL;
NEWLINEHERE;
END %LABELSTAT\ ;
PROCEDURE REPEATSTAT;
BEGIN %REPEATSTAT\
BMARKTEXT := 'R';
MAYBESLS(SPACES - FEED);
INSYMBOL ;
NEWLINEHERE;
LOOP
LOOP
STATEMENT;
EXIT IF SYTY # SEMICOLON;
INSYMBOL
END;
EXIT IF SYTY IN [UNTILSY,EOBSY,PROCEDURESY,FUNCTIONSY];
ERROR (ERRINBLKSTR);
IF NOT (SYTY IN BEGSYM) THEN INSYMBOL;
END;
NEWLINEHERE;
EMARKTEXT := 'U';
EMARKNR := CURBLOCKNR;
OLDSPACES := TRUE;
LASTSPACES := SPACES-FEED;
IF SYTY = UNTILSY THEN BEGIN
INSYMBOL;
STATEMENT;
NEWLINEHERE;
END
ELSE ERROR (MISSGENDUNTIL);
END %REPEATSTAT\ ;
BEGIN %STATEMENT\
OLDSPACESMARK := SPACES; %SAVE THE INCOMING VALUE OF SPACES TO BE ABLE TO RESTORE IT\
IF SYTY = INTCONST THEN BEGIN
INSYMBOL;
IF SYTY = COLON THEN LABELSTAT;
END;
IF SYTY IN BEGSYM THEN BEGIN
BLOCKNR := BLOCKNR + 1;
CURBLOCKNR := BLOCKNR;
BMARKNR := CURBLOCKNR;
IF NOT THENDO THEN BEGIN
NEWLINEHERE;
SPACES := SPACES + FEED;
END;
CASE SYTY OF
BEGINSY : COMPSTAT;
LOOPSY : LOOPSTAT;
CASESY : CASESTAT;
IFSY : IFSTAT;
REPEATSY: REPEATSTAT
END;
END
ELSE BEGIN
WHILE NOT (SYTY IN [SEMICOLON,FUNCTIONSY..RECORDSY]) DO INSYMBOL;
IF SYTY = DOSY THEN BEGIN
IF NOT THENDO THEN BEGIN
MAYBESLS(SPACES);
SPACES := SPACES + FEED;
THENDO := TRUE;
END;
INSYMBOL;
STATEMENT;
NEWLINEHERE;
END;
END;
SPACES := OLDSPACESMARK;
END %STATEMENT\ ;
BEGIN %BLOCK\
DOUBLEDECF := NIL;
LEVEL := LEVEL + 1;
CURPROC := LISTPTR;
SPACES := LEVEL * FEED;
REPEAT
INSYMBOL
UNTIL SYTY IN RELEVANTSYM;
%HANDLE NESTING LIST\
IF PROCSTRUCDATA.EXISTS THEN BEGIN
IF NOT (SYTY IN [FORWARDSY,EXTERNSY]) THEN BEGIN
NEW(PROCSTRUCL↑.NEXTPROC);
PROCSTRUCL := PROCSTRUCL↑.NEXTPROC;
PROCSTRUCL↑ := PROCSTRUCDATA.ITEM
END;
PROCSTRUCDATA.EXISTS := FALSE
END;
REPEAT
FWDDECL := FALSE;
WHILE SYTY IN DECSYM DO BEGIN
NEWLINEHERE;
SPACES := SPACES - FEED;
WRTELINE (BUFFERPTR);
SPACES := SPACES + FEED;
REPEAT
INSYMBOL;
IF SYTY = RECORDSY THEN RECDEF;
UNTIL SYTY IN RELEVANTSYM;
END;
WHILE SYTY IN PROSYM DO BEGIN
NEWLINEHERE;
OLDSPACES := TRUE;
IF SYTY # INITPROCSY THEN BEGIN
IF SYTY = PROCEDURESY THEN PROCDEC := PROC ELSE PROCDEC := FUNC;
INSYMBOL;
WITH PROCSTRUCDATA DO BEGIN
EXISTS := TRUE;
ITEM.PROCNAME := LISTPTR;
ITEM.NEXTPROC := NIL;
ITEM.LINENR := LINECNT+1;
ITEM.PAGENR := PAGECNT;
ITEM.PROCLEVEL := LEVEL
END;
END;
BLOCK;
IF SYTY = SEMICOLON THEN INSYMBOL;
END;
%FORWARD AND EXTERNAL DECLARATIONS MAY COME BEFORE 'VAR', ETC.\
UNTIL NOT FWDDECL;
LEVEL := LEVEL - 1;
SPACES := LEVEL * FEED;
IF (LEVEL=0) AND (SYTY=POINT) THEN WRITELN(TTY,'(NO MAIN PROGRAM)') ELSE BEGIN
IF NOT (SYTY IN [BEGINSY,FORWARDSY,EXTERNSY,EOBSY]) THEN BEGIN
ERROR (ERRINBLKSTR);
WHILE NOT (SYTY IN [BEGINSY,FORWARDSY,EXTERNSY,EOBSY]) DO INSYMBOL
END;
IF SYTY = BEGINSY THEN STATEMENT ELSE BEGIN
FWDDECL := TRUE;
INSYMBOL;
IF SYTY = LANGSY THEN INSYMBOL
END;
END;
WHILE DOUBLEDECF # NIL DO BEGIN
DOUBLEDECF↑.PROCORT↑.PROCVAR := NOTROUT;
DOUBLEDECF := DOUBLEDECF↑.NEXTPROC;
END;
IF LEVEL = 0 THEN BEGIN
IF SYTY # POINT THEN BEGIN
WRITELN (TTY,'MISSING POINT AT PROGRAM END');
WRITELN (TTY);
WRITELN (' ' : 17, ' **** MISSING POINT AT PROGRAM END ****');
INSYMBOL;
END;
WHILE SYTY # EOBSY DO INSYMBOL;
END;
END %BLOCK\ ;
PROCEDURE PRINTLISTE;
VAR
FIRSTPROC,LASTPROC, %ZEIGER ZUM DURCHHANGELN DURCH DIE BAEUME UND LISTEN BEIM AUSDRUCKEN\
PRED : LISTPTRTY;
INDEXCH : CHAR; %LAUFVARIABLE FUER DAS FELD 'FIRSTNAME' ZUM AUSDRUCKEN\
LISTPGNR: BOOLEAN; %TRUE IF THE SOURCE CONTAINS A PAGE MARK\
ITEMLEN: INTEGER; %LENGTH OF A PRINTED LINENUMBER, 9 OR 12\
PROCEDURE WRTELINENR (SPACES : INTEGER);
VAR
LINK : LINEPTRTY; %ZEIGER ZUM DURCHHANGELN DURCH DIE VERKETTUNG DER ZEILENNUMMERN\
MAXCNT, %MAXIMUM ALLOWABLE VALUE OF COUNT\
COUNT : INTEGER; %ZAEHLT DIE GEDRUCKTEN ZEILENNUMMERN PRO ZEILE\
BEGIN %WRTELINENR\
COUNT := 0;
MAXCNT := (131 - SPACES) DIV ITEMLEN; %ITEMS ARE ITEMLEN CHARS EACH\
LINK := LISTPTR↑.FIRST;
REPEAT
IF COUNT = MAXCNT THEN BEGIN
WRITELN;
WRITE (' ' : SPACES);
COUNT := 0;
END;
COUNT := COUNT + 1;
WRITE (LINK↑.LINENR * INCREMENT : 6);
IF LISTPGNR THEN WRITE('/',LINK↑.PAGENR : 2);
WRITE(' ');
LINK := LINK↑.CONTLINK;
UNTIL LINK = NIL;
END %WRTELINENR\ ;
BEGIN %PRINTLISTE\
LISTPGNR := PAGECNT > 1;
IF LISTPGNR THEN ITEMLEN := 12 ELSE ITEMLEN := 9;
FIRSTPROC := NIL;
LASTPROC := NIL;
WITH FIRSTNAME ['M']↑ DO %DELETE 'MAIN'\ IF RLINK = NIL THEN FIRSTNAME ['M'] := LLINK ELSE BEGIN
LISTPTR := RLINK;
WHILE LISTPTR↑.LLINK # NIL DO LISTPTR := LISTPTR↑.LLINK;
LISTPTR↑.LLINK := LLINK;
FIRSTNAME ['M'] := RLINK;
END;
INDEXCH := 'A';
WHILE (INDEXCH < 'Z') AND (FIRSTNAME [INDEXCH] = NIL) DO INDEXCH := SUCC (INDEXCH);
IF FIRSTNAME [INDEXCH] # NIL THEN BEGIN
PAGE;
WRITELN ('CROSS REFERENCE LISTING OF IDENTIFIERS');
WRITELN ('**************************************');
FOR INDEXCH := INDEXCH TO 'Z' DO
WHILE FIRSTNAME [INDEXCH] # NIL DO BEGIN
LISTPTR := FIRSTNAME [INDEXCH];
WHILE LISTPTR↑.LLINK # NIL DO BEGIN
PRED := LISTPTR;
LISTPTR := LISTPTR↑.LLINK;
END;
IF LISTPTR = FIRSTNAME [INDEXCH] THEN FIRSTNAME [INDEXCH] := LISTPTR↑.RLINK
ELSE PRED↑.LLINK := LISTPTR↑.RLINK;
%IS IT A PROCEDURE WHICH WAS CALLED AT LEAST ONCE?\
IF LISTPTR↑.CALLED # NIL THEN BEGIN
IF FIRSTPROC = NIL THEN BEGIN
FIRSTPROC := LISTPTR;
LASTPROC := FIRSTPROC;
LASTPROC↑.CALLED↑.PROCNAME := NIL;
END
ELSE BEGIN
LASTPROC↑.CALLED↑.PROCNAME := LISTPTR;
LASTPROC := LISTPTR;
END;
END;
WRITELN;
WRITE (LISTPTR↑.NAME : 11);
WRTELINENR (11);
END;
IF FIRSTPROC # NIL THEN BEGIN
PAGE;
WRITELN ('LISTING OF PROCEDURE AND FUNCTION CALLS');
WRITELN ('***************************************');
LASTPROC↑.CALLED↑.PROCNAME := NIL;
LASTPROC := FIRSTPROC;
WHILE LASTPROC # NIL DO BEGIN
LISTPTR :=LASTPROC;
WRITELN;WRITELN;
WRITE (LASTPROC↑.NAME:11, ' IS CALLED BY :');
WITH LASTPROC↑ DO REPEAT
WRITELN;
WRITE (' ' : 11,CALLEDBY↑.PROCNAME↑.NAME:11);
LISTPTR↑.FIRST := CALLEDBY↑.FIRST;
WRTELINENR (22);
CALLEDBY := CALLEDBY↑.NEXTPROC;
UNTIL CALLEDBY = NIL;
WRITELN; WRITELN;
IF LASTPROC↑.CALLED↑.NEXTPROC # NIL THEN BEGIN
WRITE (' ' : 11, ' AND CALLS :');
WITH LASTPROC↑.CALLED↑ DO REPEAT
WRITELN;
WRITE (' ' : 11,NEXTPROC↑.PROCNAME↑.NAME:11);
LISTPTR↑.FIRST := NEXTPROC↑.FIRST;
WRTELINENR (22);
NEXTPROC := NEXTPROC↑.NEXTPROC;
UNTIL NEXTPROC = NIL;
END;
LASTPROC := LASTPROC↑.CALLED↑.PROCNAME;
END;
PAGE;
WRITELN ('NESTING OF PROCEDURES AND FUNCTIONS');
WRITELN ('***********************************');
PROCSTRUCL := PROCSTRUCF;
REPEAT
WRITELN;
WITH PROCSTRUCL↑ DO BEGIN
WRITE (' ':PROCLEVEL*3,PROCNAME↑.NAME : 11,LINENR * INCREMENT : 6);
IF LISTPGNR THEN WRITE('/',PAGENR : 2)
END;
PROCSTRUCL := PROCSTRUCL↑.NEXTPROC;
UNTIL PROCSTRUCL = NIL;
END;
END;
END %PRINTLISTE\ ;
PROCEDURE READFILENAME;
%READS THE COMMAND LINE FOR CROSS\
%THIS LINE HAS THE FORM 'OUTPUT FILE = INPUT FILE/LINE NUMBER INCREMENT'\
%THE OUTPUT AND INPUT FILE SPECS CAN HAVE <PROT> AND [PROJ,PGMR] AND DEV: AS USUAL\
%'/LINE NUMBER INCREMENT' MAY BE OMITTED -- DEFAULT IS 100.\
%THE SWITCH /N CAUSES THE NEW FILE TO BE OUTPUT WITHOUT LINE NUMBERS\
VAR
BAD: BOOLEAN;
LEGALCHAR : SET OF CHAR; %MENGE DER LEGALEN EINGABEZEICHEN\
MAXINDEX : INTEGER; %MAXIMALER INDEX FUER DIE FUELLUNG DES FELDES 'FILENAME'\
FUNCTION READRADIX(RADIX:INTEGER):INTEGER;
VAR
PPN : INTEGER; %HILFSVARIABLE\
BEGIN %READRADIX\
PPN := 0;
CH := ' ';
WHILE (CH = ' ') AND NOT EOLN(TTY) DO READ (TTY,CH);
IF CH IN DIGITS THEN BEGIN
PPN := ORD (CH) - ORD ('0');
LOOP
READ (TTY,CH);
EXIT IF NOT (CH IN DIGITS);
PPN := PPN * RADIX + ORD(CH) - ORD ('0');
END;
END;
READRADIX := PPN;
END %READRADIX\ ;
FUNCTION INITIALS:INTEGER;
VAR
PPN,I:INTEGER;
BEGIN
PPN := 0;
REPEAT
READ(TTY,CH)
UNTIL (CH # ' ') OR EOLN(TTY);
IF CH IN LETTERS THEN BEGIN
PPN := ORD(CH) - 60B;
I := 1;
LOOP
READ(TTY,CH)
EXIT IF NOT (CH IN LETTERS);
IF I < 3 THEN PPN := PPN * 100B + ORD(CH) - 60B;
I := I +1;
END
END;
INITIALS:=PPN
END %INITIALS\ ;
BEGIN %READFILENAME\
WITH INPUTFILE DO REPEAT
BAD := FALSE;
FILENAME := ' PAS';
DEVICE := 'DSK ';
PPN := 0;
PROT := 0;
OUTPUTFILE := INPUTFILE;
I := 0;
MAXINDEX := 6;
CH := ' ';
LEGALCHAR := ALPHANUM + ['.',':','[','<','/','=','←'];
READ (TTY,CH);
IF CH = '*' THEN READ (TTY,CH);
LOOP
WHILE (CH = ' ') AND NOT EOLN (TTY) DO READ (TTY,CH);
EXIT IF (CH = ' ') OR BAD;
IF CH IN LEGALCHAR
THEN IF CH IN ALPHANUM THEN BEGIN
LOOP
I := I + 1;
IF (I <= MAXINDEX) AND (CH IN ALPHANUM) THEN FILENAME [I] := CH;
EXIT IF EOLN (TTY) OR NOT (CH IN ALPHANUM);
READ (TTY,CH);
END;
IF CH IN ALPHANUM THEN CH := ' ';
%TRASH OLD CHAR\
LEGALCHAR := LEGALCHAR - ALPHANUM - ['>',']'];
END
ELSE CASE CH OF
'.' :
BEGIN
FOR I := 7 TO 9 DO FILENAME [I] := ' ';
I := 6;
MAXINDEX := 9;
CH := ' ';
LEGALCHAR := LEGALCHAR + ALPHANUM - ['>',']',':','.'];
END;
':' :
BEGIN
FOR I := 1 TO 6 DO DEVICE [I] := FILENAME [I];
FILENAME := ' PAS';
CH := ' ';
LEGALCHAR := LEGALCHAR + ALPHANUM - ['>',']',':'];
I := 0;
END;
'<' :
BEGIN
PROT := READRADIX(8);
LEGALCHAR := LEGALCHAR + ['>'] - ['<',']',':'];
END;
'>' :
BEGIN
LEGALCHAR := LEGALCHAR - ['>'];
CH := ' ';
END;
'[' :
BEGIN
PPN := READRADIX(10) * 1000000B;
LEGALCHAR := LEGALCHAR + [']',','] - ['[','>',':'];
END;
',' :
BEGIN
PPN := INITIALS + PPN;
LEGALCHAR := LEGALCHAR - [','];
END;
']' :
BEGIN
LEGALCHAR := LEGALCHAR - [']'];
CH := ' ';
END;
'/' :
BEGIN
CASE TTY↑ OF
'0','1','2','3','4','5','6','7','8',
'9' : READ (TTY, INCREMENT);
'I' :
BEGIN
REPEAT
GET(TTY)
UNTIL (TTY↑ IN ['0' .. '9']) OR EOLN(TTY);
IF TTY↑ IN ['0'..'9'] THEN BEGIN
READ(TTY,FEED);
END
END;
'F':
BEGIN
FAST := TRUE;
GET(TTY);
END;
'N' :
BEGIN
SEQUENCE := FALSE; GET(TTY)
END
END;
CH := ' '; %THIS CAUSES A NEW CH TO BE READ\
END;
'=',
'←' :
BEGIN
OUTPUTFILE := INPUTFILE;
FILENAME := ' PAS';
DEVICE := 'DSK ';
PPN := 0;
MAXINDEX := 6;
PROT := 0;
I := 0;
CH := ' ';
LEGALCHAR := LEGALCHAR +
ALPHANUM + ['.',':','[','<']- ['=','←'];
END
END
ELSE BEGIN
WRITELN (TTY, 'INVALID INPUT ''', CH, '''');
WRITE(TTY, '*');
BAD := TRUE;
BREAK;
READLN(TTY);
END;
END %LOOP\;
UNTIL (CH # '*') AND NOT BAD;
IF INPUTFILE.FILENAME = ' PAS' THEN INPUTFILE := OUTPUTFILE;
WITH OUTPUTFILE DO IF FILENAME = ' PAS' THEN BEGIN
FILENAME := INPUTFILE.FILENAME;
FILENAME [7] := 'N';
FILENAME [8] := 'E';
FILENAME [9] := 'W';
END;
END %READFILENAME\ ;
BEGIN %MAIN\
INIT;
WITH INPUTFILE DO
LOOP
READFILENAME;
RESET (INPUT,FILENAME,PROT,PPN,DEVICE);
EXIT IF NOT EOF (INPUT);
WRITELN (TTY);
WRITE (TTY,DEVICE,':',FILENAME : 6,'.',FILENAME [7],FILENAME [8],FILENAME [9]);
IF PPN # 0 THEN BEGIN
WRITE(TTY,' [',PPN DIV 1000000B:6,',');
WRITE(TTY,CHR(PPN DIV 10000B MOD 100B + 60B));
WRITE(TTY,CHR(PPN DIV 100B MOD 100B +60B));
WRITE(TTY,CHR(PPN MOD 100B + 60B),']')
END;
WRITELN (TTY,' NOT FOUND');
WRITE(TTY, '*');
BREAK(TTY);
END;
WRITELN (TTY);
WRITELN (TTY,VERSION);
WRITELN (TTY);
BREAK;
%FIND MAX POSSIBLE LINE NO WITH THIS INCREMENT, LEAVING 1 FOR SOS BUG\
MAXINC := (99999 DIV INCREMENT) - 1;
%WE HAVE ONLY 13 BITS (0..8191) FOR THE LINE COUNTER\
IF MAXINC > 8000 THEN MAXINC := 8000;
WITH OUTPUTFILE DO BEGIN
REWRITE (NEWFIL,FILENAME);
FILENAME[7]:='L'; FILENAME[8]:='S'; FILENAME[9]:='T';
IF FAST THEN REWRITE(OUTPUT, FILENAME, 0, 0, 'NUL ')
ELSE REWRITE (OUTPUT, FILENAME);
END;
CH := ' ';
DATUM;
HEADER;
BLOCK;
WRTELINE (BUFFLEN+2);
IF ERRFLAG THEN WRITE(TTY, '? ') ELSE WRITE (TTY,'NO ');
WRITELN (TTY,MESSAGE);
IF FAST THEN REWRITE(OUTPUT, OUTPUTFILE.FILENAME, 0, 0, 'DSK ');
PRINTLISTE;
END %CROSS\.